home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / boyer-moore.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  11.9 KB  |  274 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ; boyer-moore.lisp
  3. ;
  4. ; The Boyer/Moore string search algorithm.
  5. ; Replaces MCL's "Search Files" algorithm with Boyer/Moore and gives feedback
  6. ; while the search is progressing.
  7.  
  8. ; To do
  9. ; Only finds one occurrence per block.
  10.  
  11. ;;;;;;;;;;;;;
  12. ;;
  13. ;; Modification History
  14. ;;
  15. ;; 04/28/93 mwp Release
  16. ;; ??       bill no longer fails to find string that crosses the first block boundary.
  17. ;; 02/04/93 bill put up dialog before (directory ...) so that user can abort by
  18. ;;               closing the dialog. Gracefully handle user closing of the dialog.
  19. ;; 02/02/93 bill (directory ... :resolve-aliases t). Maybe this should be a switch.
  20. ;; 10/16/92 bill The behavior of the selection changed in set-table-sequence.
  21. ;;               Bullet-proof this code so it works independently of how
  22. ;;               the selection changes.
  23. ;; 08/20/92 bill double clicking on white space in the "Files containing..."
  24. ;;               dialog no longer brings up a "New..." window.
  25. ;; ------------- 2.0
  26. ;; 10/08/91 bill mac-file-io moves to CCL package
  27. ;; 09/05/91 bill Removed last vestige of LAP
  28.  
  29. (in-package :ccl)
  30.  
  31. (eval-when (:compile-toplevel :execute :load-toplevel)
  32.   (require :mac-file-io)
  33. )
  34.  
  35. (defstruct bm-tables 
  36.   string                                ; the search string as a vector of character codes
  37.   len                                   ; the length of the search string
  38.   match                                 ; index in string -> shift for last chars match
  39.   mismatch                              ; char -> shift for last char mismatch
  40.   )
  41.  
  42. (defun compute-bm-tables (string &optional case-matters)
  43.   (setq string (ensure-simple-string (if case-matters string (string-upcase string))))
  44.   (let* ((len (length string))
  45.          (len-1 (1- len))
  46.          (len-2 (1- len-1))
  47.          (mismatch (make-array 256 :element-type t :initial-element len))
  48.          (match (make-array (max 0 len-1) :element-type t))
  49.          (pred (if case-matters #'char= #'char-equal)))
  50.     (declare (fixnum len len-1 len-2))
  51.     ; compute mismatch table.
  52.     ; mismatch[i] = how far to shift if there is a mismatch on the first
  53.     ; compare (with string[len-1]) and the character in the text is (code-char i)
  54.     (dotimes (i len-1)
  55.       (declare (fixnum i))
  56.       (setf (aref mismatch (char-code (schar string i))) (- len-1 i)))
  57.     ; Compute match table
  58.     ; match[i] = how far to shift if there is a mismatch in the ith position
  59.     ; of the search string (i < len-1).
  60.     (dotimes (i len-1)                  ; i is mismatch position
  61.       (declare (fixnum i))
  62.       (setf (aref match i)
  63.             (block match
  64.               (do ((end len-2 (1- end)))
  65.                   ((< end 0) len)
  66.                 (declare (fixnum end))
  67.                 (do ((j len-1 (1- j))
  68.                      (k end (1- k)))
  69.                     ((< k 0)
  70.                      (return-from match (- len-1 end)))
  71.                   (declare (fixnum j k))
  72.                   (when (eql j i) 
  73.                     (if (not (funcall pred (schar string j) (schar string k)))
  74.                       (return-from match (- len-1 end)) 
  75.                       (return)))
  76.                   (unless (funcall pred (schar string j) (schar string k))
  77.                     (return)))))))
  78.     (make-bm-tables :string (map 'vector #'char-code string) :len len :mismatch mismatch :match match)))
  79.  
  80. (defmacro %char-code-upcase (char-code)
  81.   (let ((c (gensym)))
  82.     `(the fixnum
  83.           (let ((,c ,char-code))
  84.             (declare (fixnum ,c))
  85.             (if (and (<= (char-code #\a) ,c)
  86.                      (<= ,c (char-code #\z)))
  87.               (the fixnum (+ ,c (- (char-code #\A) (char-code #\a))))
  88.               ,c)))))
  89.  
  90. ; Search array from start to end for the string in the bm-tables descriptor
  91. (defun bm-search-array (bm-tables array start end)
  92.   (declare (fixnum start end)
  93.            (type macptr array))
  94.   (declare (optimize (speed 3) (safety 0)))
  95.   (let* ((string (bm-tables-string bm-tables))
  96.          (len (bm-tables-len bm-tables))
  97.          (len-1 (1- len))
  98.          (match (bm-tables-match bm-tables))
  99.          (mismatch (bm-tables-mismatch bm-tables))
  100.          (i (+ start len-1))
  101.          (char-code 0))
  102.     (declare (fixnum len len-1 i char-code))
  103.     (macrolet ((array-ref (array index) `(%char-code-upcase (%get-unsigned-byte ,array ,index))))
  104.       (loop
  105.         (when (>= i end) (return nil))
  106.         (let ((array-idx i)
  107.               (string-idx len-1))
  108.           (declare (fixnum array-idx string-idx))
  109.           (if (not (eql (the fixnum (svref string string-idx))
  110.                         (setq char-code (array-ref array array-idx))))
  111.             (incf i (the fixnum (svref mismatch char-code)))
  112.             (loop
  113.               (when (< (decf string-idx) 0)
  114.                 (return-from bm-search-array (the fixnum (- i len-1))))
  115.               (decf array-idx)
  116.               (when (not (eql (the fixnum (svref string string-idx))
  117.                               (array-ref array array-idx)))
  118.                 (return (the fixnum (incf i (the fixnum (svref match string-idx)))))))))))))
  119.  
  120.  
  121. (defconstant $bm-buffer-size 8192)
  122.  
  123. (defun find-bm-tables-in-file (bm-tables file &optional found-function)
  124.   (unless found-function
  125.     (let (res)
  126.       (setq found-function
  127.             #'(lambda (pos)
  128.                 (if pos
  129.                   (push pos res)
  130.                   (prog1 (nreverse res) (setq res nil)))))))                
  131.   (with-FSopen-file (pb file)
  132.     (let* ((len (bm-tables-len bm-tables))
  133.            (len-1 (1- len))
  134.            (buffer-size (+ $bm-buffer-size len-1))
  135.            (size 0)
  136.            (bytes-read 0)
  137.            (base 0)
  138.            (index 0))
  139.       (declare (fixnum len buffer-size size bytes-read base))
  140.       (%stack-block ((buf buffer-size))
  141.         (with-macptrs ((buf+len-1 (%inc-ptr buf len-1))
  142.                        (buf+$bm-buffer-size (%inc-ptr buf $bm-buffer-size)))
  143.           (setq bytes-read (setq size (fsread pb $bm-buffer-size buf)))
  144.           (with-macptrs ((ptr (%inc-ptr buf+$bm-buffer-size (- len-1))))
  145.             (#_BlockMove ptr buf+$bm-buffer-size len-1))
  146.           (loop
  147.             (when (> bytes-read 0)
  148.               (setq index 0)
  149.               (loop
  150.                 (if (setq index (bm-search-array bm-tables buf index size))
  151.                   (progn
  152.                     (unless (funcall found-function (+ base index))
  153.                       (return-from find-bm-tables-in-file nil))
  154.                     (setq index (the fixnum (1+ (the fixnum index)))))
  155.                   (return))))
  156.             (when (< bytes-read $bm-buffer-size)
  157.               (return (funcall found-function nil)))
  158.             (incf base $bm-buffer-size)
  159.             (#_BlockMove buf+$bm-buffer-size buf len-1)
  160.             (setq bytes-read (fsread pb $bm-buffer-size buf+len-1))
  161.             (setq size (+ len-1 bytes-read))))))))
  162.  
  163.  
  164. ; Call FOUND-FUNCTION with one arg, the position in the file, for each
  165. ; occurrence of STRING in FILE.  Calls FOUND-FUNCTION with an arg of NIL when
  166. ; the last occurrence has been found, and returns the value as the value
  167. ; of BM-FIND-STRING-IN-FILE.
  168. ; If FOUND-FUNCTION returns NIL, return NIL from BM-FIND-STRING-IN-FILE.
  169. (defun bm-find-string-in-file (string file &optional found-function)
  170.   (find-bm-tables-in-file (compute-bm-tables string) file found-function))
  171.  
  172. ; Call FOUND-FUNCTION with two args, the file & the position in the file,
  173. ; for each occurrence of STRING in one of the FILES.
  174. ; If FOUND-FUNCTION returns NIL, go immediately to the next file.
  175. ; Otherwise, continue searching in the current file.
  176. ; Calls FOUND-FUNCTION with a second arg of T before starting to search each file
  177. ; and with a second arg of NIL at the end of searching each file.
  178. ; Calls FOUND-FUNCTION with a first arg of NIL when the search is all over.
  179. (defun bm-find-string-in-files (string files &optional found-function)
  180.   (unless found-function
  181.     (setq found-function
  182.           (let (res one-file)
  183.             #'(lambda (file pos)
  184.                 (cond ((eq file nil) (prog1 (nreverse res) (setq res nil)))
  185.                       ((eq pos t) (setq one-file nil))
  186.                       ((eq pos nil) (when one-file
  187.                                       (push (cons file (nreverse one-file)) res)))
  188.                       (t (push pos one-file)))))))
  189.   (let ((bm (compute-bm-tables string))
  190.         search-file)
  191.     (flet ((inner-found-function (pos)
  192.              (funcall found-function search-file pos)))
  193.       (declare (dynamic-extent inner-found-function))
  194.       (dolist (file files)
  195.         (setq search-file file)
  196.         (funcall found-function file t)
  197.         (find-bm-tables-in-file bm file #'inner-found-function))
  198.       (funcall found-function nil nil))))
  199.  
  200. (defun bm-find-string-in-dir (string dir &optional found-function)
  201.   (bm-find-string-in-files string (directory dir) found-function))
  202.  
  203. ;;;;;;;;;;;;;
  204. ;;
  205. ;; Upate MCL's "Search Files" command
  206. ;;
  207.  
  208. (defvar *search-files-dialog* nil)
  209.  
  210. ; Stub, so that redefining bm-di-dialog-file-search-internal won't
  211. ; require reevaluating the (setf (symbol-function 'do-dialog-file-search) ...) form.
  212. (defun bm-do-dialog-file-search (pathname string)
  213.   (bm-do-dialog-file-search-internal pathname string))
  214.  
  215. (defun bm-do-dialog-file-search-internal (pathname string)
  216.   (let* ((dialog (select-item-from-list
  217.                   nil
  218.                   :window-title (format nil "Files containing ~s" string)
  219.                   :modeless t
  220.                   :action-function
  221.                   #'(lambda (list)
  222.                       (when list
  223.                         (maybe-start-isearch (ed (car list)) string)))))
  224.          (*search-files-dialog* dialog)
  225.          (sequence (car (subviews dialog 'sequence-dialog-item)))
  226.          (button (default-button dialog))
  227.          files)
  228.     (catch dialog                       ; thrown to by window-close method below
  229.       (set-table-sequence sequence (list (format nil "Finding ~s" pathname)))
  230.       (unless (setq files (directory pathname :resolve-aliases t))
  231.         (set-table-sequence sequence (list "No files correspond to:" pathname))
  232.         (return-from bm-do-dialog-file-search-internal nil))
  233.       (set-table-sequence sequence nil)
  234.       (set-cell-font sequence #@(0 0) :italic)
  235.       (set-table-sequence sequence (list (car files)))
  236.       (flet ((f (file index)
  237.                (without-interrupts
  238.                 (flet ((ensure-selected-cell (sequence new-cell)
  239.                          (let ((old-cell (first-selected-cell sequence)))
  240.                            (unless (eql new-cell old-cell)
  241.                              (when old-cell (cell-deselect sequence old-cell))
  242.                              (when new-cell (cell-select sequence new-cell))))))
  243.                   (cond ((null file)
  244.                          (set-cell-font sequence #@(0 0) nil)
  245.                          (let ((sel (first-selected-cell sequence)))
  246.                            (set-table-sequence
  247.                             sequence (cdr (table-sequence sequence)))
  248.                            (when sel
  249.                              (setq sel
  250.                                    (if (eql sel #@(0 0))
  251.                                      nil
  252.                                      (make-point (point-h sel) (1- (point-v sel))))))
  253.                            (ensure-selected-cell sequence sel)))
  254.                         ((eq index t)
  255.                          (setf (car (table-sequence sequence)) file)
  256.                          (redraw-cell sequence #@(0 0)))
  257.                         (index
  258.                          (let ((sel (or (first-selected-cell sequence) #@(0 1))))
  259.                            (set-table-sequence 
  260.                             sequence (nconc (table-sequence sequence) (list file)))
  261.                            (ensure-selected-cell sequence sel)
  262.                            (dialog-item-enable button)
  263.                            nil))
  264.                         (t nil))))))
  265.         (declare (dynamic-extent #'f))
  266.         (bm-find-string-in-files string files #'f)))))
  267.  
  268. (defmethod window-close :after ((w select-dialog))
  269.   (if (eq w *search-files-dialog*)
  270.     (throw w nil)))
  271.  
  272. (let ((*warn-if-redefine* nil)
  273.       (*warn-if-redefine-kernel* nil))
  274.   (setf (symbol-function 'do-dialog-file-search) #'bm-do-dialog-file-search))